home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
eulisp
/
feel0_89.lha
/
Feel
/
Boot
/
class-hacks.em
< prev
next >
Wrap
Lisp/Scheme
|
1993-02-02
|
9KB
|
258 lines
;; Eulisp Module
;; Author: pab
;; File: class-hacks.em
;; Date: Wed May 13 11:45:11 1992
;;
;; Project:
;; Description:
;;
(defmodule class-hacks
(standard0
list-fns
scan-args
)
()
;; macros to get us started.
;; idea is that we wind up with 3 things to do:
;; 0: allocation
;; 1: class hierarchy
;; 2: slot-descriptions
;; 3: define method-functions
;; 4: install methods
(defconstant class-slots (mk-finder))
(defconstant class-supers (mk-finder))
(deflocal *class-allocation-forms* '(progn))
(deflocal *class-set-hierarchy-forms* '(progn))
(deflocal *slot-accessor-forms* '(progn))
(deflocal *slot-description-forms* '(progn))
(deflocal *method-definition-forms* '(progn))
(deflocal *method-installation-forms* '(progn))
(defmacro do-class-allocation ()
*class-allocation-forms*)
(defmacro do-slot-accessors-definition ()
*slot-accessor-forms*)
(defmacro do-set-hierarchy ()
`(initialize-hierarchy ,*class-set-hierarchy-forms*))
(defmacro do-slot-description-allocation ()
(print `(initialize-slots ,*slot-description-forms*)))
(defmacro do-method-definitions ()
*method-definition-forms*)
(defmacro do-method-installation ()
*method-installation-forms*)
(defmacro class-allocation ()
*class-allocation-forms*)
(defmacro slot-accessors-definition ()
*slot-accessor-forms*)
(defmacro set-hierarchy ()
`(initialize-hierarchy ,*class-set-hierarchy-forms*))
(defmacro slot-description-allocation ()
(print `(initialize-slots ,*slot-description-forms*)))
(defmacro method-definitions ()
*method-definition-forms*)
(defmacro method-installation ()
*method-installation-forms*)
(export do-class-allocation do-slot-accessors-definition do-set-hierarchy
do-slot-description-allocation do-method-definitions do-method-installation
class-allocation slot-accessors-definition set-hierarchy slot-description-allocation
method-definitions method-installation)
(defmacro reset-classes ()
(setq *class-allocation-forms* '(progn))
(setq *slot-accessor-forms* '(progn))
(setq *class-set-hierarchy-forms* '(list))
(setq *slot-description-forms* '(list))
(setq *method-definition-forms* '(progn))
(setq *method-installation-forms* '(progn))
nil)
(export reset-classes)
;; helper macro
(defmacro def-exported-constant (name . rest)
`(progn (defconstant ,name ,@rest)
(export ,name)))
(export def-exported-constant)
(defmacro define-prim-class (class supers slot-description-list . initargs)
(let ((slot-description-list (mapcar (lambda (x) (append (list 'owner-class class)
(cons 'name x)))
slot-description-list)))
((setter class-slots) class slot-description-list)
((setter class-supers) class supers)
(nconc *class-allocation-forms*
(allocation-forms class initargs))
(nconc *slot-accessor-forms*
(mapcar make-prim-slot-accessors slot-description-list))
(nconc *class-set-hierarchy-forms*
(hierarchy-forms class supers initargs))
(nconc *slot-description-forms*
(slot-description-forms class slot-description-list initargs))
nil))
(export define-prim-class)
(defun make-prim-slot-accessors (slot-desc)
(let ((position (scan-args 'position slot-desc nil))
(reader (scan-args 'reader slot-desc nil))
(writer (scan-args 'writer slot-desc nil))
(accessor (scan-args 'accessor slot-desc nil)))
(when (null position)
(error "Position not defined." clock-tick))
`(progn ,(if (null reader) nil
`(def-exported-constant ,reader
(primitive-reader ,position)))
,(if (null writer) nil
`(def-exported-constant ,writer
(primitive-writer ,position)))
,(if (null accessor) nil
`(progn (def-exported-constant ,accessor
(primitive-reader ,position))
((bf-setter bf-setter) ,accessor
(primitive-writer ,position))))
)))
;; make a class....
(defun allocation-forms (class initargs)
(if (scan-args 'allocate initargs nil)
(let ((meta (scan-args 'metaclass initargs 'class)))
`((defconstant ,class (allocate-object class)) ;; get this right later
(set-type ,class class-type)
(export ,class)))
(list `(export ,class))))
'(defun hierarchy-forms (class supers initargs)
(let ((cpl (if (null supers) `(list ,class)
`(cons ,class
(%class-precedence-list ,(car supers)))))
(subs (if (null supers)
nil
`((bf-setter %class-subclasses) ,(car supers)
(cons ,class (%class-subclasses ,(car supers)))))))
`((generic_generic_prin\,Object "Defining: " (standard-error-stream))
(generic_generic_prin\,Object ',class (standard-error-stream))
((bf-setter %class-precedence-list) ,class ,cpl)
(generic_generic_prin\,Object "CPL\n" (standard-error-stream))
((bf-setter %class-subclasses) ,class nil)
(generic_generic_prin\,Object "Sub-set" (standard-error-stream))
((bf-setter %class-superclasses) ,class (list ,@supers))
,subs
((bf-setter %class-name) ,class ',class)
((bf-setter %class-initargs) ,class ,(scan-args 'class-initargs initargs nil))
(set-class-of ,class ,(scan-args 'metaclass initargs 'class))
((bf-setter %class-instance-size) ,class ,(calculate-slot-count class)))))
(defun hierarchy-forms (class supers initargs)
`((list ,class
,(if (null supers) nil `(list ,@supers))
,(scan-args 'metaclass initargs 'class)
',class
',(scan-args 'direct-initargs initargs nil)
,(calculate-slot-count class))))
(defun calculate-slot-count (class)
(let ((supers (class-supers class)))
(if (null (class-supers class))
(list-length (class-slots class))
(+ (list-length (class-slots class))
;; single inheritance, right?
(calculate-slot-count (car (class-supers class)))))))
'(defun slot-description-forms (class slots initargs)
(labels ((make-slot-description (slot-desc)
`(let ((slot (allocate-object ,(or (scan-args 'class slot-desc nil)
'local-slot-description))))
(generic_generic_prin\,Object ',slot-desc (standard-error-stream))
(fill-slot-description slot ',slot-desc))))
(let ((slot-list (mapcar make-slot-description slots)))
(format t "slots: ~a~%" slot-list)
`((generic_generic_prin\,Object ,class (standard-error-stream))
(let ((lst (list ,@slot-list)))
((bf-setter %class-slot-list) ,class
(nconc lst (if (null (%class-superclasses ,class)) nil
(%class-slot-list (car (%class-superclasses ,class))))))
)))))
;; NB No support for default initargs...
(defun slot-description-forms (class slots initargs)
(print slots)
(list (list 'list class
(cons 'list (mapcar (lambda (slotd)
`(list ,(or (scan-args 'class slotd nil) 'local-slot-description)
',slotd))
slots)))))
(defmacro define-generic (name argtype)
`(progn (def-exported-constant ,name (allocate-object generic-function))
((bf-setter %generic-discriminator) ,name (default-compute-discriminating-function ,name))
((bf-setter %generic-name) ,name ',name)
((bf-setter %generic-argtype) ,name ,argtype)
))
(export define-generic)
(defun method-extra-args ()
(if (compile-time-p)
()
(list '***method-status-handle*** '***method-args-handle***)))
(defmacro method-lambda (args . junk)
`(lambda ,(append (method-extra-args) args) ,@junk))
;; primitive readers and writers
;; (compile-time
(progn (defmacro primitive-reader (pos)
(if (compile-time-p)
(if (< pos 10)
(make-symbol (format nil "reader-~a" pos))
`(compile-inline 1 (slot-ref ,pos)))
(lambda (x) 0)))
(defmacro primitive-writer (pos)
(if (compile-time-p)
(if (< pos 10)
(make-symbol (format nil "writer-~a" pos))
`(compile-inline 2 (set-slot ,pos)))
(lambda (x) 0)))
)
;; )
;; (interpret-time
;; (progn (defmacro primitive-reader (pos)
;; `(lambda (x)
;; (slot-value-using-class class x ,pos)))
;; (defmacro primitive-writer (pos)
;; `(lambda (x val)
;; ((setter slot-value-using-class) class x ,pos val)))))
(export method-lambda primitive-writer primitive-reader)
(defmacro system-name (name)
(make-symbol (format nil "%_*~a*_%" name)))
(defmacro quote-system-name (name)
(list 'quote (make-symbol (format nil "%_*~a*_%" name))))
(export system-name quote-system-name)
;; end module
)